{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE ScopedTypeVariables,BangPatterns,DeriveDataTypeable #-}
module Simulator where

import Types
import ManagementStore
import Random
import Constants
import Management
import ManagementStore

import Data.Array.Vector
import Data.Array.Vector.UArr
import Data.Array.ST
import Data.List (sortBy,foldl',lookup,nub,intersperse)
import Data.Word
import Data.Maybe
import qualified Data.Map as Map (Map,insert,keys,findWithDefault)
import Data.Binary
import Data.Generics


import Control.Monad
import Control.Monad.ST
import Control.DeepSeq

import Statistics.RandomVariate as RV

-- import GHC.Prim

import Debug.Trace

-- *** BANKS ***

type BankID = Int

type Accounts = Map.Map (Date,AccID) Double

data Bank 
    = B { management:: !Management,
          -- balance sheet
          bankcash::Cash, -- liquids with reserve
          -- next two stricts cut down about half the stack
          assets :: !(Cash,[Contract]), -- cache the total
          liabilities :: !(Cash,[Contract]), -- cache the total
          deposits::Cash, -- retail deposits
          depositRate::Double, -- rate paid on deposits - rate paid on cash is world-dependent
          -- statistics and accounting
          profit :: ![Cash],
          dividends :: ![Cash],
          costs:: Int, -- The RAW cost in evaluation steps 
          accounts :: Accounts, -- (Map.Map (Date,AccID) Double),
          bankID :: BankID,
          -- regulation and failure
          regulatorControl::Bool,         -- is the institution under self or reg. management
          failTime::Double,
	  failPenalty::Cash } -- management score penalty for allowing failure
    deriving (Data,Typeable)

instance (NFData Bank) where
   rnf (B a b c d e f g h i j k l m n) =
       rnf a `seq`
       rnf b `seq`
       rnf c `seq`
       rnf d `seq`
       rnf e `seq`
       rnf f `seq`
       rnf g `seq`
       rnf h `seq`
       rnf i `seq` -- accounts
       rnf j `seq`
       rnf k `seq`
       rnf l `seq`
       rnf m `seq`
       rnf n `seq`
       ()  

lastprofit (B {profit=[]}) = 0
lastprofit (B {profit=h:_}) = h

instance Binary Bank where
  put (B a b c d e f g h i j k l m n) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h >> put i >> put j >> put k >> put l >> put m >> put n
  get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> get >>= \i -> get >>= \j -> get >>= \k -> get >>= \l -> get >>= \m -> get >>= \n -> return (B a b c d e f g h i j k l m n)

sumDividends :: Bank -> Cash
sumDividends = sum.dividends

showBList [] = ""
showBList (b:bs) = " " ++ (show b) ++ "\n" ++ (showBList bs)

bookEquity b@(B {}) =
    let loanval = valueBook ass
        depositval = valueBook liab
    in cash + loanval - depositval - deps
    where valueBook = fst -- foldl (\x y -> x + (valueBond y)) 0 
	  cash = bankcash b
	  ass = assets b
          liab = liabilities b
          deps = deposits b

valueBank b
    = bookEquity b -- use book values for now XXX - need a better model here if we implement takeovers 

bankCapital b@(B {})
    = (valueBank b)/riskWeightedAssets b

riskWeightedAssets b = (fst $ assets b) -- for now cash has weighting 0, all else weighting 1

bankLiquidity b@(B {})
    = (bankcash b)/(fst $ assets b)

valBL = sum.(Prelude.map valueBond)

instance Show Bank where
  show bb@(B { bankcash = c,
               assets = (_,a),
               liabilities = (_,l) ,
               management = m,
               regulatorControl = r})
      = "Bank:" ++ (if r
                    then " (under regulator adminstration)"
                    else "") ++ "\n Assets:"
        ++ "\n  Cash   : " ++ (show c)
        ++ "\n  Loans  : " ++ (show $ valBL a) ++ "\n" ++ (showBL a)
        ++ "\n  Total A: " ++ (show ((valBL a) + c))
        ++ "\n\n Liabilities: "
        ++ "\n  Loans  : " ++ (show $ valBL l) ++ "\n" ++ (showBL l)
        ++ "\n  Deposit: " ++ (show $ deposits bb) ++ " Rate: " ++ (show $ depositRate bb)
        ++ "\n  Total L: " ++ (show ((valBL l) + (deposits bb)))
        ++ "\n\n Equity: \n  Equity : " ++ (show $ valueBank bb)
        ++ "\n  Divs   : " ++ (show $ sum $ dividends bb)
        ++ "\n  LProfit: " ++ (show $ take 12 $profit bb )
        ++ "\n  Cap Rat: " ++ (show (bankCapital bb))
        ++  "\n\nMANAGEMENT:\n" ++ (show m) 

showBL [] = ""
showBL (b:bs) = (show b) ++ "\n" ++ (showBL bs)

-- *** BANK ACCOUNTS ***

-- uses an "Accid" - otherwise accounts are a memory hog
-- TODO - unbox Dates which should make the lookup faster

aDates :: Accounts -> [Date]
aDates a = nub [ fst b | b <- Map.keys a ]

aItems :: Accounts -> [Int]
aItems a = nub [ snd b | b <- Map.keys a ]

printAccount :: Date -> Accounts -> String
printAccount d a =
    let ai = aItems a
    in (show d) ++ "\n" ++ (concat $ [ (show i) ++ " : " ++ (lup i) ++ "\n" | i <- ai ])
    where lup e = show $ Map.findWithDefault 0 (d,e) a

insEntries :: Date -> [(Int,Double)] -> Accounts -> Accounts
insEntries d = flip (foldl (\a (s,e) -> Map.insert (d,s) e a))

accountEntries = [("Cash"),
                  ("Loan Assets"),
                  ("Total Assets"),
                  ("Deposit Liab"),
                  ("Loan Liab"),
                  ("Total Liab"),
                  ("Equity"),
                  -- Income statement
                  ("Interest Income"),
                  ("Interest Expense"),
                  ("Net Interest Income"),
                  ("Costs"),
                  ("Provisions"),
                  ("PreTaxProfit"),
                  ("XXX Dividends XXX"),
                  ("XXX Tax XXX"),
                  -- Statistics
                  ("Net Interest Margin"),
                  ("Return on Assets"),
                  ("Return on Equity")]


type AccID = Int
aid :: String -> Int
aid "Cash" = 0
aid "Loan Assets" = 1
aid "Total Assets" = 2
aid "Deposit Liab" = 3
aid "Loan Liab" = 4
aid "Total Liab" = 5
aid "Equity" = 6
aid "Interest Income" = 7
aid "Interest Expense" = 8
aid "Costs" = 9
aid "Net Interest Income" = 10
aid "Provisions" = 11
aid "PreTaxProfit" = 12
aid "XXX Dividends XXX" = 13
aid "XXX Tax XXX" = 14
-- Statistics
aid "Net Interest Margin" = 15
aid "Return on Assets" = 16
aid "Return on Equity" = 17
aid x = (trace (show x) undefined)

printAccs :: Accounts -> String
printAccs a =
    let dasets = segmentup 4 (aDates a)
        segmentup :: Int -> [Date] -> [[Date]]
        segmentup n d
            | length d <= n = [d]
            | otherwise = (take n d):(segmentup n (drop n d))
    in concat (intersperse "\n\n" (Prelude.map (printAccRow a) dasets))

printAccRow :: Accounts -> [Date] -> String
printAccRow a ds =
    let indent = maximum (Prelude.map length accountEntries) + 3
        allEntries = [ (show d) | d <- ds ] ++ [ lup d (aid e) | d <- ds, e <- accountEntries ]
        elength = maximum (Prelude.map length allEntries) + 2
        lup d e = showf $ Map.findWithDefault 0 (d,e) a
        prow e = (ljprint indent e) ++ concat [ rjprint elength (lup d (aid e)) | d <- ds ] ++ "\n"
        phead = (ljprint indent "") ++ concat [ rjprint elength (show d) | d <- ds ] ++ "\n"
        ljprint i s = s ++ (concat $ replicate (i - (length s)) " ")
        rjprint i s = (concat $ replicate (i - (length s)) " ") ++ s
    in phead ++ concat (Prelude.map prow accountEntries)

data Party 
    = Depositor |
      Borrower |
      Regulator
      deriving (Data,Typeable,Eq,Show)

instance NFData Party where
  rnf x = x `seq` ()

instance Binary Party where
  put Depositor = putWord8 0
  put Borrower = putWord8 1
  put Regulator = putWord8 2
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> return Depositor
      1 -> return Borrower
      2 -> return Regulator
      _ -> fail "no parse"


data Regulator = R { minLiquidRatio::Double,
                     minCapitalRequirement::Double }
    deriving (Data,Typeable)

instance (NFData Regulator) where
   rnf (R a b) = rnf a `seq` rnf b

instance Binary Regulator where
  put (R a b) = put a >> put b
  get = get >>= \a -> get >>= \b -> return (R a b)


type PolicyGet = Bank -> Policy

-- *** WORLDS ***

#ifdef DIAGNOSTICS
type ProposalDiagnostic = (Maybe BankID,BondProposal,Party)

diagnosticSummary :: World -> String
diagnosticSummary w
    =  concat $ intersperse "\n" $ [show (c,b,p) | (c,b,p) <- ds, p == Depositor ] 
      ++  [ show (c,b,p) | (c,b,p) <- ds, p == Borrower ] 
      where 
          ds = diagnostic w

#else
type ProposalDiagnostic = ()

diagnosticSummary :: World -> String
diagnosticSummary _ = ""

#endif




data World = W { date::Date,
                 cashRateParams::CashRateParams,
                 banks::[Bank], 
                 depositors::[ContractFactory],
                 borrowers::[ContractFactory], 
                 regulator::Regulator,
		 diagnostic::[ProposalDiagnostic] }
           | NullWorld
    deriving (Data,Typeable)

instance (NFData World) where
   rnf (W a b c d e f g) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f `seq` rnf g 

instance Binary World where
  put (W a b c d e f g) = putWord8 0 >> put a >> put b >> put c >> put d >> put e >> put f >> put g
  put NullWorld = putWord8 1
  get = do
    tag_ <- getWord8
    case tag_ of
      0 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> get >>= \e -> get >>= \f -> get >>= \g -> return (W a b c d e f g)
      1 -> return NullWorld
      _ -> fail "no parse"

-- Mean; Amplitude; Period (years)
type CashRateParams = (Double,Double,Double)

cashRate :: CashRateParams -> Date -> Double
cashRate (m,a,p) d = m + a * (sin $ 2 * pi * (dateFloat d) / p)
    where adj d = id
    
-- *** WORLD SIMULATOR ***

-- Note that BinaryDerive gets confused by strict arguments

data SimState 
    = Sim { steps::Int,
            bound::Int,
            worldsteps::Int,
            mutator::Mutator,
            mgt::ManagementStore,
            world:: !World,
            keepAccounts:: Bool,
            simid:: Int}
    deriving (Show,Data,Typeable)

-- leave mgtstore for now
instance (NFData SimState) where
   rnf (Sim a b c d _ f g h) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf f `seq` rnf g `seq` rnf h

instance Binary SimState where
  put (Sim a b c d e f g h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
  get = get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> 
          get >>= \e -> get >>= \f -> get >>= \g -> get >>= \h -> return (Sim a b c d e f g h)

instance Show World where
  show (W { date = d,
            banks = b }) = "Date = " ++ (show d) ++ "\n" ++ (showBList b)
  show NullWorld = "NULLWORLD"


instance (Binary Seed) where
  put s = put (show s)
  get = get >>= \s -> return (read s)


-- Insolvency/liquidity rules:
-- "Cash" is assumed to be some pool of liquid assets, which pays
-- the world's short-term RFR. There's no bank-bills or CDs for
-- very-low-but-not-quite risk-free depositing.
--
-- An organization is forced by the regulator to keep particular
-- capital and liquid asset/cash ratios.  If it fails to do so, it is taken 
-- over by the regulator (effectively wound up in this scenario).
--
-- 


-- bonds pay interest on month 0
stepBond :: Date -> Contract -> Double -> (Contract,Double,Double)
stepBond _ (DefaultedBond v _) _ =  (NullBond,(v),0)
stepBond _ NullBond _ = (NullBond,0,0)
stepBond date b@(Bond {maturity=m,principal=p,rate=r,rdefault=rd,recovery=rec}) randnum
    = let ncash = if date >= m
                  then p * (r + 1)
                  else interest
          nbond = if date >= m
                  then NullBond
                  else b
          interest = if (monthPart (minusDate m date)) == 0
                     then p * r
                     else 0
      in if randnum < rd/(fromIntegral miy)
         then ((DefaultedBond { recval = p * rec,
                                principal = p}),
                    0,0)
         else (nbond,ncash,interest)


-- *** BANK STEPPING ***

{-
-- Performs all the business except for transactions
-}

-- fuggly style due to many rewrites. The accountancy stuff is a mess.  TODO - cleanup
-- Accounts are a memory hog and flog the GC. No idea why - it should be 20*12 years *17 entries *32 banks doubles - 150,000 words/ iteration
--  if we need two 64 bit words for a double + (2 big tuple + (2 + 2 + 2 - date) + 2 accid) - 8*12 *150k = 10 Meg? - actually about right ...  
-- Historical accounts 
-- not recorded except if set as a simulator option (which allows
-- for roe, roa and nim stats) or unless it is the last simulator step

-- XXX - check - are accounts *before* or *after* end of month ?  This needs correction, some things are a month out of date
stepBank :: Gen a -> Date -> Double -> Bool -> Bank -> ST a Bank
stepBank randgen date cashrate keepAccounts (b@(B {bankcash=cash}) ) =
    do (!nassets,newcash,interestincome) <- {-# SCC "lnum88" #-} 
           foldM (stepper randgen date) ([],0,0) ({-# SCC "lnum88a" #-} snd$assets b)
       return  (let (!nliab,newpays,interestexpense) = {-# SCC "lnum89" #-} foldl' liabstepper ([],0,0) liab 
                    liabstepper :: ([Contract],Double,Double) -> Contract -> ([Contract],Double,Double)
                    liabstepper (!ls,np,ii) (l) =  {-# SCC "lnum90a" #-}let (nl,nnp,nii) =  {-# SCC "lnum90" #-}(stepBond date l 1.0)
                                               in {-# SCC "lnum91" #-}(nl:ls,np+nnp,nii+ii)
                    fcash =  {-# SCC "lnum92" #-} cash +  newcash + cashincome - newpays - depcost - opCosts
                    provisions =  {-# SCC "lnum93" #-} sum [bondloss b | b <- nassets ]
                    pretaxprof =  {-# SCC "lnum94" #-} nii - provisions - opCosts -- XXX - tax and dividends in paydividends and tax
                    nii =  {-# SCC "lnum95" #-} interestincome + cashincome - interestexpense - depcost
                    nbank0 =  {-# SCC "lnum97" #-} b { bankcash = {-# SCC "lnum97a" #-}fcash,
                                 assets = {-# SCC "lnum97b" #-}(valBL nassets,nassets),
                                 liabilities = {-# SCC "lnum97c" #-} (valBL nliab,nliab),
	                         profit = {-# SCC "lnum97d" #-}pretaxprof:(profit b),
                                 costs = 0 } -- reset the costs
                    nbank = if keepAccounts
                            then nbank0 { accounts = nent `deepseq`{-# SCC "lnum97e" #-}insEntries date nent (accounts b) }
                            else nbank0
                    p =  {-# SCC "lnum102" #-} management b
                    (asst,ass) =  {-# SCC "lnum104" #-} assets b
                    (liabt,liab) =  {-# SCC "lnum105" #-} liabilities b
                    totassets =  {-# SCC "lnum106" #-} asst + bankcash b
                    totliab =  {-# SCC "lnum107" #-} liabt + deps
                    equity =  {-# SCC "lnum108" #-} totassets - totliab
                    cashincome =  {-# SCC "lnum108a" #-} cash * cashrate / fromIntegral miy
                    deps =  {-# SCC "lnum109" #-} deposits b
                    deprate =  {-# SCC "lnum110" #-} (depositRate b + cashrate) / fromIntegral miy
                    depcost =  {-# SCC "lnum96" #-} deps * deprate -- cost of deposit funding
                    opCosts = costFactor * (fromIntegral $ costs b)
                    --
                    rc =  {-# SCC "lnum111" #-} regulatorControl b
                    -- statistics
                    divs =  {-# SCC "lnum113" #-} dividends b 
                    nim' =  {-# SCC "lnum114" #-} nii * (fromIntegral $ miy) / totassets
                    roa' =  {-# SCC "lnum115" #-} (pretaxprof * (fromIntegral $ miy)) / totassets 
                    roe' =  {-# SCC "lnum116" #-} (pretaxprof * (fromIntegral $ miy)) / equity
                    -- XXX interest spread needs to be added
                    nent = {-# SCC "lnum118" #-}  [ -- Balance Sheet
                             (aid "Cash",{-# SCC "lnum120" #-} cash),
                             (aid "Loan Assets",{-# SCC "lnum121" #-}asst),
                             (aid "Total Assets",{-# SCC "lnum122" #-}totassets),
                             (aid "Deposit Liab",{-# SCC "lnum123" #-}deps),
                             (aid "Loan Liab",{-# SCC "lnum124" #-}liabt),
                             (aid "Total Liab",{-# SCC "lnum125" #-}totliab),
                             (aid "Equity",{-# SCC "lnum126" #-}equity),
                             -- Income statement
                             (aid "Interest Income",{-# SCC "lnum128" #-}interestincome + cashincome),
                             (aid "Interest Expense",{-# SCC "lnum129" #-}interestexpense + depcost),
                             (aid "Net Interest Income",{-# SCC "lnum130" #-}nii),
                             (aid "Provisions",{-# SCC "lnum131" #-}provisions),
                             (aid "PreTaxProfit",{-# SCC "lnum132" #-}pretaxprof),
                             (aid "Costs", opCosts),
                             (aid "XXX Dividends XXX", {-# SCC "lnum134" #-}0),
                             (aid "XXX Tax XXX",0),
                             -- Statistics
                             (aid "Net Interest Margin",{-# SCC "lnum135" #-}nim'),
                             (aid "Return on Assets",{-# SCC "lnum136" #-}roa'),
                             (aid "Return on Equity",{-# SCC "lnum137" #-}roe') ]
                in {-# SCC "lnum138" #-}nbank)

stepper :: Gen a -> Date -> ([Contract],Cash,Cash) -> Contract -> ST a ([Contract],Cash,Cash)
stepper randgen d (oa,oc,ii) a = {-# SCC "lnum141" #-}
    do rn::Double <- RV.uniform randgen -- (0,1]
       return (let (b,c,i) = {-# SCC "lnum143" #-}(stepBond d a rn) 
               in (b:oa,c+oc,i+ii))


payDividendAndTax :: Bank -> Bank
payDividendAndTax b 
    = if lastprofit b > 0
      then b { bankcash = (bankcash b) - divs - tax,
               dividends = divs:(dividends b) }
      else b { dividends = 0:(dividends b) }
    where !divs = (((divrate b $ management b)/(fromIntegral miy)) * (lastprofit b - tax))
          !tax = ((taxrate/(fromIntegral miy)) * (lastprofit b))
-- divs are paid monthy - essentially put into a "dividend" account and then commited.

-- no tax losses - very simple income tax paid monthly

-- divrate b (SimpleM _ _ (PNum d) _) = d
-- use the next one to enforce rule - divs < profits.  if special dividends are permitted, second one is used
-- divrate b (SimpleM _ _ r _) = cap 0.0 1.0 $ fst$evalNum r zeroDate b zeroBond 0 50
divrate b (SimpleM _ _ r _)
        | isNaN dval = 0
        | isInfinite dval = 0
        | dval < 0 = 0 
        | otherwise = dval
        where dval = fst$evalNumP r zeroDate b zeroBondP 0 0 50
taxrate = 0.3

cap min max n 
    | n < min = min
    | n > max = max
    | otherwise = n

          
-- for testing
stepBank1 :: Bank -> Bank
stepBank1 b = runST go
              where go = do g <- initialize (singletonU 42)
                            stepBank g zeroDate 0.03 True b

bondloss (DefaultedBond x y) = y - x
bondloss _ = 0



-- **** TRANSACTIONS ****


-- others not implemented yet  

newProposal :: Gen a -> Date -> ContractFactory -> ST a BondProposal
-- newContract d g f | trace ("newContract : " ++ (show f)) False = undefined   
newProposal g d (BondCF { defaultDist = dd, principalDist = pd, rateStart = rstart, rateStep = rstep,
                          durationDist = durd, recoveryDist = recd })
    = do !gdur <- (getDNum g durd) 
         !grstep <- (getDNum g rstep) 
         !grstart <- (getDNum g rstart) 
         !gprin <- (getDNum g pd)            
         !gdef <- (getDNum g dd)
         !grec <- (getDNum g recd)
         return (d,sumDate d (D ((round gdur),0)),grstart,gprin,gdef,grec)


adjustProposal :: Gen a -> ContractFactory -> BondProposal -> ST a BondProposal
adjustProposal g (BondCF {rateStep = rs} ) (!d,!m,!rate,!p,!rd,!r)
    = do !adjustment <- (getDNum g rs)
         return (d,m,rate + adjustment,p,rd,r)


--  Calculate a new collection of possible deposits and loans
--  each bank (reordered randomly) gets an opportunity to accept or
--  reject each deposit.
--
--  We get maxProposalAttempts at rejiggering rejected debt
--
-- Banks are rotated at the end of each round to stop one from hogging the good debt
--
-- BankCosts needs to be an STU for efficiency - it's effectively an opcounter for the tight inner loop of the
-- simulator ...
type BankCosts a = STUArray a Int Int

-- depends on each bank having a unique bankid
checkProposal:: Gen a -> Date -> (ContractFactory,Party) -> Double -> [Bank] -> BankCosts a -> ST a (ProposalDiagnostic,[Bank]) 
checkProposal g d@(D (!d1,!d2)) (cf,!p) cr bs co 
    = do !proposal@(!d,!m,!rate,!p,!rd,!r) <- newProposal g d cf
         (res',(bp',bs')) <- runNUntil (checkprop g co) (proposal,bs) Nothing maxProposalAttempts
#ifdef DIAGNOSTICS
         let diag = (res',bp',p)
#else
         let diag = ()
#endif
         return (diag,rotate bs') 
    where checkprop :: Gen a -> BankCosts a -> (BondProposal,[Bank]) -> Int -> ST a (Maybe BankID,(BondProposal,[Bank]))
          checkprop g' co' (bp,x) n = do nprop <- adjustProposal g' cf bp
                                         checkProposal1 d nprop cr p x [] co'

-- run func at most n n times or until it reports non-nothing and return the result
-- n must be non-negative at the start 
runNUntil :: (Monad m) => (a -> Int -> m (Maybe b,a)) -> a -> Maybe b -> Int -> m (Maybe b,a)
runNUntil func x (Just y) _ = return (Just y,x)
runNUntil func x res 0 = return (res,x)
runNUntil func x Nothing n = do func x n >>= \(res,x') -> runNUntil func x' res (n-1)

justNullBankID = Just 0

checkProposal1:: Date -> BondProposal -> Double -> Party -> [Bank] -> [Bank] -> BankCosts a -> ST a (Maybe BankID,(BondProposal,[Bank]))
checkProposal1 _ bp _ _ [] bs co = return (Nothing,(bp,bs)) -- contract was rejected 
checkProposal1 d bp cr p (b@(B {bankID= bid}):bs) brest co =
    do oldco <- readArray co bid
       writeArray co bid (oldco + cost)
       if {-# SCC "cp1-21" #-} res
        then {-# SCC "cp1-31" #-}return (
#ifdef DIAGNOSTICS
                                         Just $ bankID newb,
#else
                                         justNullBankID,
#endif
                                         (bp,{-# SCC "cp1-33" #-}brest ++ {-# SCC "cp1-34" #-}({-# SCC "cp1-35" #-}newb:{-# SCC "cp1-36" #-}bs)))
        else {-# SCC "cp1-41" #-}checkProposal1 d bp cr p bs ({-# SCC "cp1-48" #-}(:)b brest) co
    where (res,cost) = {-# SCC "cp1-54" #-}(evaluateContractP d b ({-# SCC "cp1-57" #-}pfetch p b) bp cr 0 maxEvaluationDepth)
          contract = {-# SCC "cp1-61" #-}buildContract bp
          newb = {-# SCC "cp1-81" #-}(acceptContract p d b contract) 

-- constructs the bank with the contract accepted
acceptContract :: Party -> Date -> Bank -> Contract -> Bank
acceptContract Depositor d b c 
    = b {liabilities = (lt + principal c,(c:ll)),
         bankcash = (bankcash b) + (valueBond c) }
	where (lt,ll) = liabilities b
acceptContract Borrower d b c -- can't accept a contract if not enough cash
    = if ((bankcash b1) < 0)
      then b
      else b1
    where b1 = (acceptContractB d b c)

acceptContractB d b c
    = b {assets = (at + principal c,(c:al)),
         bankcash = (bankcash b) - (valueBond c)}
	where (at,al) = assets b

cleanupContract :: Bank -> Bank
cleanupContract b 
    = b { assets = {-# SCC "lnum546" #-} (fst$assets b,cleanup (snd $ assets b)),
          liabilities =  {-# SCC "lnum547" #-}  (fst$liabilities b,cleanup (snd $ liabilities b)) }
      where cleanup !l = {-# SCC "lnum548" #-} filter (/= NullBond) l



-- two ints - first is ops-so-far, second is maxops.

evaluateContractP :: Date -> Bank -> Policy -> BondProposal -> Double -> Int -> Int -> (Bool,Int) -- (result,cost)
evaluateContractP !d !b !p !c !cr !(td::Int) !(max::Int)
	| td < max = {-# SCC "ecsimp1" #-} evaluateContractP' d b p c cr (tdinc) max
	| otherwise = {-# SCC "ecsimp2" #-} (False,td) -- if we take to long default-to-failure	
        where !tdinc = td + 1

-- slow, so the shotgun approach to strictness - more an experiment than anything
-- going nuts with ! resulted in a 100% speed increase - steps went fro 7.5 secs to just over 3 secs.
--  now to find out why ...
evaluateContractP' :: Date -> Bank -> Policy -> BondProposal -> Double -> Int -> Int -> (Bool,Int) -- (result,cost)
evaluateContractP' (D (!_,!_)) !_ PAccept !(!_,!_,!_,!_,!_,!_) c !i !m = {-# SCC "ec1" #-} (True,i)
evaluateContractP' !_ !_ PReject !(!_,!_,!_,!_,!_,!_) !c !i m = {-# SCC "ec2" #-} (False,i)
evaluateContractP' !d !b@(B{management=mgt}) (PCall n) !l !c !i m = {-# SCC "ec3" #-} evaluateContractP d b pol l c i m
    where pol = (mRegs mgt) !! (n - 1) -- note it's now possible to loop!  we need an analysis budget ahead of time, so we don't loop
evaluateContractP' !d !b (PIf cond t f) !l@(!_,!_,!_,!_,!_,!_) c !i m = {-# SCC "ec4" #-} -- rely on laziness here not to calcuate the irrelevant leg ...
    if test
    then (evaluateContractP d b t l c tcost m)
    else (evaluateContractP d b f l c tcost m)
    where (test,tcost) = {-# SCC "ec6" #-} (evaluateContractP d b cond l c i m)
evaluateContractP' !d !b (PNumTest n1 dir n2) !l@(!_,!_,!_,!_,!_,!_) c !i m
    = {-# SCC "ec5" #-} ((lookupDir dir) n1res n2res,n2cost)
      where (n1res,n1cost) = (evalNumP n1 d b l c i m) 
            (n2res,n2cost) = (evalNumP n2 d b l c n1cost m)

rateScale = 10.0 -- typical max rate is 0.1
principalScale = 0.02 -- typical max principal is 50
defScale = 20.0 -- typical max def rate is 0.05
matScale = 0.1 -- typical max maturity is 10 years
bcScale = 0.0001 -- typical max cash is 10000
capScale = 1.0 -- typical max cap ratio is 1
liqScale = 1.0 -- typical max liq ratio is 1
crScale = 5.0 -- typical max liq ratio is 0.2
-- no guards here, just in contract which is where calls happen
-- about a 1% perfomance improvement for making i strict
-- (st,mat,r,p,rd,rec)
evalNumP :: PNum -> Date -> Bank -> BondProposal -> Double -> Int -> Int -> (Double,Int) -- (result,cost)
evalNumP PRate _ _ (st,mat,r,p,rd,rec) _ (!i) m = (r*rateScale,i+1)
evalNumP PPrincipal _ _ (st,mat,r,p,rd,rec) _ (!i) m = (p*principalScale,i+1)
evalNumP PDefault _ _ (st,mat,r,p,rd,rec) _ (!i) m = (rd*defScale,i+1)
evalNumP PMaturity da _ (st,mat,r,p,rd,rec) _ (!i) m
    = (matScale * (dateFloat $ sumDate mat da),i+1)
evalNumP PBankCash _ b _ _ (!i) m = (bcScale * bankcash b,i+1)
evalNumP PCapitalRat _ b _ _ (!i) m = (bankCapital b,i+1)

evalNumP PLiqRat _ b _ _ (!i) m = ((bankLiquidity b),i+1)
evalNumP (PNum n) _ _ _ _ (!i) m = (n,i+1)
evalNumP PCashRate _ _ _ c (!i) m = (crScale * c,i+1)

evalNumP (PSum n1 n2) a1 a2 a3 c (!i) m = (s1+s2,c2)
    where (s1,c1) = (evalNumP n1 a1 a2 a3 c i m) 
          (s2,c2) = (evalNumP n2 a1 a2 a3 c c1 m)
evalNumP (PDiff n1 n2) a1 a2 a3 c (!i) m = (s1-s2,c2)
    where (s1,c1) = (evalNumP n1 a1 a2 a3 c i m) 
          (s2,c2) = (evalNumP n2 a1 a2 a3 c c1 m)
evalNumP (PProd n1 n2) a1 a2 a3 c (!i) m = (s1*s2,c2)
    where (s1,c1) = (evalNumP n1 a1 a2 a3 c i m) 
          (s2,c2) = (evalNumP n2 a1 a2 a3 c c1 m)
evalNumP (PDiv n1 n2) a1 a2 a3 c (!i) m = (s1/s2,c2)
    where (s1,c1) = (evalNumP n1 a1 a2 a3 c i m) 
          (s2,c2) = (evalNumP n2 a1 a2 a3 c c1 m)

{-

-- WARNING - this may be expensive as we trapse through the loan book 
-- XXX - still needs fixing up ...  The whole idea here needs rethinking ..

evalNumP (PBSSum side pol) da b _ i m
    = ( bres,cost )
      where (caccept,cost) = foldl ev1 ([],i) contracts
            ev1 (res,costtodate) c = let (r,ncost) = evaluateContractP da b pol c costtodate m
                                     in (r:res,ncost)
            contracts = (snd $ ga side b) :: [Contract]
            bres = sum [ principal c | (ca,c) <- zip caccept contracts, ca ]
-}
evalNumP _ _ _ _ _ i m = (0,i+1)


ga Asset = assets
ga Liability = liabilities

pfetch Depositor b = depPolicy b
pfetch Borrower b = loanPolicy b

loanPolicy b = 
    if not (regulatorControl b)
    then loanPolicy1 (management b)
    else PReject -- run-off mode
depPolicy b = 
    if not (regulatorControl b)
    then depPolicy1 (management b)
    else PReject -- again runoff mode
depPolicy1 (SimpleM d _ _ _) = d
loanPolicy1 (SimpleM _ l _ _) = l

-- *** WORLD STEPPING ***

regulate :: Double -> Regulator -> Bank -> Bank
regulate d r b 
    = if (((bankLiquidity b) > (minLiquidRatio r)) &&
            ((bankCapital b) > (minCapitalRequirement r))) || (regulatorControl b)
      then b
      else (b {regulatorControl = True, failTime = d})

transact :: Gen a -> Date -> Double -> [Bank] -> BankCosts a -> [ProposalDiagnostic] ->
            [(ContractFactory,Party)]  -> ST a ([Bank],[ProposalDiagnostic]) -- TODO - diagnostics blank for now
transact _ _ _ b co pds [] = 
    do b' <- applyCosts b co
       return (b',pds)
transact gen d cr b co pds (o:os)
    = do (pd,b') <- checkProposal gen d o cr b co
#ifdef DIAGNOSTICS
         transact gen d cr b' co (pd:pds) os
#else
         transact gen d cr b' co [] os
#endif

applyCosts bs co = 
    do ac <- getAssocs co
       return [ b { costs = fromJust $ Data.List.lookup (bankID b) ac } | b <- bs ]

{- 
- yield curve diagnostic output in the second return argument (Contract,Party,Bool)
- the "Boolean" is whether the contract was accepted or not
- usage - the disposition of a contract - how is it "used" 
-}


stepWorld :: Gen a -> Bool -> World -> ST a World
-- stepWorld g w | trace ("Date is " ++ (show $ date w) ++ " Fail " ++ (show $(dateFloat ((D 20 0) `minusDate` (date w))))) False = undefined
stepWorld g ka w 
    = -- w `deepseq`
      do banks1 <- stepBanks g d (banks w) -- pay interest on the first of the month
         banks1s <- shuffle g banks1  
         allOffers <- shuffle g ([ (d,Depositor ) | d <- depositors w ] ++
                                 [ (l,Borrower ) | l <- borrowers w ] )
         let range = (1,maximum [(bankID b)::BankID | b <- banks1s ]) :: (Int,Int)
         cost0 <- (newArray range (0 :: Int) ) 
         (banks3,diag) <- transact g d cr (banks2f banks1s) cost0 [] allOffers 
         -- mapM (\i -> readArray cost0 i >>= (\x -> unsafeIOToST $ putStr ((show x) ++ " "))) [fst range .. snd range]
         -- unsafeIOToST $ putStr "\n"
         return w {date = incDate d,
                   banks = (banks6f . banks5f) banks3 
#ifdef DIAGNOSTICS
	           , diagnostic = diag ++ (diagnostic w) } 
#else
                   }
#endif
    where d = date w
          banks2f b1 = map cleanupContract b1
          banks5f b4 = map payDividendAndTax b4
          --- XXX (D 20 0) hard coded for now XXX XXX XXX!!!
          banks6f b5 = map (regulate (dateFloat ((D (20,0)) `minusDate` d)) (regulator w)) b5
          cr = cashRate (cashRateParams w) (date w)
          stepBanks g d b = mapM (stepBank g d cr ka) b

nStepWorld :: Gen a -> Bool -> Int -> World -> ST a World
nStepWorld g ka i w = foldM (\ (!x) _ -> stepWorld g ka x) w (replicate i 0)


